home *** CD-ROM | disk | FTP | other *** search
/ SPACE 1 / SPACE - Library 1 - Volume 1.iso / program / 16 / linea.fth < prev    next >
Text File  |  1985-11-19  |  11KB  |  379 lines
  1. \ "Line A" Graphics Interface
  2. \ Written by Jesse Taylor.
  3.  
  4. decimal
  5.  
  6. variable a-vars
  7. \ Create a name which will return the address stored in a-vars plus an offset
  8. : afield:  ( offset -- )
  9.    create ,
  10. \ does> @ a-vars @ +
  11.    ;code
  12.    sp )+       a0 lmove
  13.    a0 )        a0 lmove    
  14.    a-vars l#)  a0 adda
  15.    a0       sp -) lmove
  16. c;
  17.  
  18. \ These fields reflect the offsets into the table pointed to by A0 when the
  19. \ line A graphics are first initialized.
  20.  
  21.   0 afield: v_planes
  22.   2 afield: v_lin_wr
  23.   4 afield: contrl
  24.   8 afield: intin
  25.  12 afield: ptsin
  26.  16 afield: intout 
  27.  20 afield: ptsout
  28.  24 afield: _fg_bp_1    
  29.  26 afield: _fg_bp_2
  30.  28 afield: _fg_bp_3
  31.  30 afield: _fg_bp_4
  32.  32 afield: _lstlin
  33.  34 afield: _ln_mask
  34.  36 afield: _wrt_mod
  35.  38 afield: _x1
  36.  40 afield: _y1
  37.  42 afield: _x2
  38.  44 afield: _y2
  39.  46 afield: _patptr
  40.  50 afield: _patmsk
  41.  52 afield: _multifill
  42.  54 afield: _clip
  43.  56 afield: _xmn_clip
  44.  58 afield: _ymn_clip
  45.  60 afield: _xmx_clip
  46.  62 afield: _ymx_clip 
  47.  64 afield: _xacc_dda
  48.  66 afield: _dda_inc
  49.  68 afield: _t_sclsts          
  50.  70 afield: _mono_status
  51.  72 afield: _sourcex
  52.  74 afield: _sourcey
  53.  76 afield: _destx
  54.  78 afield: _desty
  55.  80 afield: _delx
  56.  82 afield: _dely 
  57.  84 afield: _fbase
  58.  86 afield: _fwidth
  59.  90 afield: _style
  60.  92 afield: _litemask
  61.  94 afield: _skewmask
  62.  96 afield: _weight
  63.  98 afield: _r_off
  64. 100 afield: _l_off
  65. 102 afield: _scale
  66. 104 afield: _chup
  67. 106 afield: _text_fg
  68. 108 afield: _scrtchchp
  69. 112 afield: _scrpt2
  70. 114 afield: _text_bg
  71. 116 afield: _copytran
  72.  
  73. \ these are the regular program variables
  74. variable patmskv  7 patmskv !
  75. hex
  76.  
  77. decimal
  78. \ this is a table containing the three resolution modes on the st
  79.  create rez-table   320 w, 200 w,  640 w, 200 w,  640 w, 400 w,
  80.  
  81. hex
  82.  44c constant rez-flag
  83.  
  84. : get-rez  ( -- x y )  \ return current screen resolution
  85.    rez-flag c@  4 *  rez-table + dup w@ swap 2+ w@ 
  86. ;
  87. code init-a  ( -- addr )  \ line A graphics init routine
  88.    a000 w,
  89.    a0   a-vars l#)  lmove
  90. c;
  91. code put-pix  ( -- )   \ set pixel
  92.    a001 w, 
  93. c;
  94. code get-pix  ( -- n )  \ get pixel
  95.    a002 w,
  96.    d0 sp -) lmove
  97. c;
  98. code do-line  ( -- )  \ draw line
  99.    a003 w,
  100. c;
  101. code h-line  ( -- )  \ horizontal line
  102.    a004 w,
  103. c;
  104. code fill-rec  ( -- )  \ filled rectangle
  105.    a005 w,
  106. c;
  107. code fill-poly  ( -- )  \ filled polygon
  108.    a006 w,
  109. c;
  110. code show-mouse  ( -- )  \ show mouse
  111.    a009 w,
  112. c;
  113. code hide-mouse  ( -- )  \ hide mouse
  114.    a00a w,
  115. c;
  116. code transform-mouse  ( -- )  \ transform mouse cursor
  117.    a00b w,
  118. c;
  119. code copy-raster  ( -- )  \ raster copy
  120.    a00e w,
  121. c;
  122. decimal
  123.  
  124. : set-clip  ( x1 y1 x2 y2 --  ) \ set the clipping rectangle
  125.    _ymx_clip  w!   _xmx_clip w!
  126.    _ymn_clip  w!   _xmn_clip w!
  127. ;
  128. : color  ( pl1 pl2 pl3 pl4 -- )  \ set the 4 color planes
  129.    _fg_bp_4 w!  _fg_bp_3 w!   _fg_bp_2 w!  _fg_bp_1 w!
  130. ;
  131. : lmask!  ( n -- )  \ set the line mask variable
  132.    _ln_mask w!
  133. ;
  134. : line-a-init  ( -- )  \ high level line a initialization routine
  135.    init-a
  136.    -1 lmask!
  137.    -1  _lstlin     w!   
  138.    0   _multifill  w!
  139.    1 0 0 0 color
  140.    patmskv @  _patmsk w!
  141.    0 0 640 400 set-clip
  142. ;
  143. : !pix  ( x y value --  ) \ high level pixel setting routine
  144.    intin @  w!
  145.    ptsin @ swap  over 2+ w!  w!
  146.    put-pix
  147. ;
  148. : @pix  ( x y -- value )  \ high level pixel fetching
  149.    ptsin @  swap over 2+  w!  w!  get-pix
  150. ;
  151. : draw  ( x1 y1 x2 y2 -- )  \ high level line routine
  152.    _y2 w!   _x2 w!    _y1 w!   _x1 w!
  153.    do-line
  154. ;
  155.  
  156. : rectangle ( x1 y1 x2 y2 --  )  \ draw a filled rectangle
  157.    _y2 w!   _x2 w!    _y1 w!   _x1 w!
  158.    fill-rec
  159. ;
  160. decimal
  161.  
  162. : poly-line  ( addr n --  )  \ draw a line polygon
  163.    4* over + swap
  164.    do   i w@  i 2+ w@  i 4 + w@  i 6 + w@  draw   4 +loop
  165. ;
  166.  
  167. code polygon  ( y1 y2 addr n --  )  \ fast polygon inner loop
  168.    sp )+          d0          lmove
  169.    a-vars l#)     a1          lmove   
  170.    ' contrl >body @  a1 d)    a2          lmove 
  171.    d0             2 a2 d)     wmove
  172.    ' ptsin >body @  a1 d)     d7          lmove
  173.    sp )+    ' ptsin >body @  a1 d)    lmove 
  174.    sp )+          d6          lmove
  175.    sp )+          d5          lmove
  176.    a3             sp -)       lmove   \ Save a3
  177.    a1             a3          lmove   \ a1 gets clobbered so we use a3
  178.    d5             d6          sub
  179.    begin
  180.     d5 ' _y1 >body @  a3 d) wmove
  181.     hex a006 w, decimal
  182.     1 d5 addq
  183.    d6 dbra
  184.    d7  ' ptsin >body @  a3 d) lmove
  185.    sp )+          a3          lmove
  186. c;
  187.  
  188. \ this is an example of the use of the polygon routine
  189. \ create poly1
  190. \        100 w, 100 w,    100 w, 200 w,
  191. \        1   w, 300 w,    600 w, 250 w,
  192. \        200 w, 375 w,    100 w, 100 w,
  193. \ : polytest
  194. \  poly1 5  poly-line
  195. \ ;
  196.  
  197. hex 44e @ constant scradr  decimal
  198.  
  199. create mfdb
  200.    scradr ,
  201.    rez-flag c@ dup  4*  rez-table + dup w@ swap @ ,
  202.    16 / w,
  203.    0 w,
  204.    2* 1 max 4 swap - 1 max  w,
  205.    0 w,
  206.    0 ,
  207.  
  208.  
  209. \ raster copy routine is a low level bit map move routine it is fast
  210.  
  211. decimal
  212.  
  213. : rasmove  ( sx1 sy1 sx1 sx2 dx1 dy1 dx2 dy2 m -- )
  214.    mfdb dup  contrl @  14 + 2!
  215.    intin @  w!
  216.    ptsin @  dup 14 +
  217.     do  i w!  -2 +loop
  218.    copy-raster
  219. ;
  220.  
  221. \ patterns 
  222. create p0
  223. -1 , -1 , -1 , -1 , -1 , -1 , -1 , -1 ,
  224. -1 , -1 , -1 , -1 , -1 , -1 , -1 , -1 ,
  225. -1 , -1 , -1 , -1 , -1 , -1 , -1 , -1 ,
  226. hex
  227. create p1
  228. -1 , c000c000 , c000c000 , c000c000 ,
  229.      c000c000 , c000c000 , c000c000 , c000c000 ,
  230. -1 , c000c000 , c000c000 , c000c000 ,
  231.      c000c000 , c000c000 , c000c000 , c000c000 ,
  232. -1 , c000c000 , c000c000 , c000c000 ,
  233.      c000c000 , c000c000 , c000c000 , c000c000 ,
  234.  
  235. create p2
  236. cccc3333 , cccc3333 , cccc3333 , cccc3333 ,
  237. cccc3333 , cccc3333 , cccc3333 , cccc3333 ,
  238. cccc3333 , cccc3333 , cccc3333 , cccc3333 ,
  239. cccc3333 , cccc3333 , cccc3333 , cccc3333 ,
  240. cccc3333 , cccc3333 , cccc3333 , cccc3333 ,
  241. cccc3333 , cccc3333 , cccc3333 , cccc3333 ,  
  242.  
  243. create p3
  244. c0c03030 , 0c0c0303 ,  c0c03030 , 0c0c0303 ,
  245. c0c03030 , 0c0c0303 ,  c0c03030 , 0c0c0303 ,
  246. c0c03030 , 0c0c0303 ,  c0c03030 , 0c0c0303 ,
  247. c0c03030 , 0c0c0303 ,  c0c03030 , 0c0c0303 ,
  248. c0c03030 , 0c0c0303 ,  c0c03030 , 0c0c0303 ,
  249. c0c03030 , 0c0c0303 ,  c0c03030 , 0c0c0303 ,
  250.  
  251. create p4
  252. 03030c0c , 3030c0c0 ,  03030c0c , 3030c0c0 ,
  253. 03030c0c , 3030c0c0 ,  03030c0c , 3030c0c0 ,
  254. 03030c0c , 3030c0c0 ,  03030c0c , 3030c0c0 ,
  255. 03030c0c , 3030c0c0 ,  03030c0c , 3030c0c0 ,
  256. 03030c0c , 3030c0c0 ,  03030c0c , 3030c0c0 ,
  257. 03030c0c , 3030c0c0 ,  03030c0c , 3030c0c0 ,
  258.  
  259. create p5
  260. c003300c , 0c3003c0 ,  03c00c30 , 300cc003 ,
  261. c003300c , 0c3003c0 ,  03c00c30 , 300cc003 ,
  262. c003300c , 0c3003c0 ,  03c00c30 , 300cc003 ,  
  263. c003300c , 0c3003c0 ,  03c00c30 , 300cc003 ,
  264. c003300c , 0c3003c0 ,  03c00c30 , 300cc003 ,
  265. c003300c , 0c3003c0 ,  03c00c30 , 300cc003 ,
  266.  
  267. create p6
  268. c3c33c3c , 3c3cc3c3 , c3c33c3c , 3c3cc3c3 ,
  269. c3c33c3c , 3c3cc3c3 , c3c33c3c , 3c3cc3c3 ,
  270. c3c33c3c , 3c3cc3c3 , c3c33c3c , 3c3cc3c3 ,
  271. c3c33c3c , 3c3cc3c3 , c3c33c3c , 3c3cc3c3 ,
  272. c3c33c3c , 3c3cc3c3 , c3c33c3c , 3c3cc3c3 ,
  273. c3c33c3c , 3c3cc3c3 , c3c33c3c , 3c3cc3c3 ,
  274.  
  275. create p7
  276. ffff8001 , 80018001 , ffff0180 , 01800180 ,
  277. ffff8001 , 80018001 , ffff0180 , 01800180 ,
  278. ffff8001 , 80018001 , ffff0180 , 01800180 ,
  279. ffff8001 , 80018001 , ffff0180 , 01800180 ,
  280. ffff8001 , 80018001 , ffff0180 , 01800180 ,
  281. ffff8001 , 80018001 , ffff0180 , 01800180 , 
  282.  
  283. create p8
  284. 40a08040 , 80a05515 , 08081004 , 10048aaa ,
  285. 40a08040 , 80a05515 , 08081004 , 10048aaa ,
  286. 40a08040 , 80a05515 , 08081004 , 10048aaa ,
  287. 40a08040 , 80a05515 , 08081004 , 10048aaa ,
  288. 40a08040 , 80a05515 , 08081004 , 10048aaa ,
  289. 40a08040 , 80a05515 , 08081004 , 10048aaa ,
  290.  
  291. create p9
  292. 44440000 , 44440000 , 44440000 , 44440000 ,
  293. 44440000 , 44440000 , 44440000 , 44440000 ,
  294. 44440000 , 44440000 , 44440000 , 44440000 ,
  295. 44440000 , 44440000 , 44440000 , 44440000 ,
  296. 44440000 , 44440000 , 44440000 , 44440000 ,
  297. 44440000 , 44440000 , 44440000 , 44440000 ,
  298.  
  299. create p10
  300. ffff2222 , ffff1111 , ffff8888 , ffff4444 ,
  301. ffff2222 , ffff1111 , ffff8888 , ffff4444 ,
  302. ffff2222 , ffff1111 , ffff8888 , ffff4444 , 
  303. ffff2222 , ffff1111 , ffff8888 , ffff4444 ,
  304. ffff2222 , ffff1111 , ffff8888 , ffff4444 ,
  305. ffff2222 , ffff1111 , ffff8888 , ffff4444 ,
  306.  
  307. create p11
  308. 44448282 , 01010202 , 04040808 , 10102828 ,
  309. 44448282 , 01010202 , 04040808 , 10102828 ,
  310. 44448282 , 01010202 , 04040808 , 10102828 ,
  311. 44448282 , 01010202 , 04040808 , 10102828 ,
  312. 44448282 , 01010202 , 04040808 , 10102828 ,
  313. 44448282 , 01010202 , 04040808 , 10102828 ,
  314.  
  315. create p12
  316. 80808888 , 8080aaaa , 80808888 , 8080aaaa ,
  317. 80808888 , 8080aaaa , 80808888 , 8080aaaa ,
  318. 80808888 , 8080aaaa , 80808888 , 8080aaaa ,
  319. 80808888 , 8080aaaa , 80808888 , 8080aaaa ,
  320. 80808888 , 8080aaaa , 80808888 , 8080aaaa ,
  321. 80808888 , 8080aaaa , 80808888 , 8080aaaa , 
  322.  
  323. create p13
  324. 00001010 , 44440000 , 00001010 , 44440000 ,
  325. 00001010 , 44440000 , 00001010 , 44440000 ,
  326. 00001010 , 44440000 , 00001010 , 44440000 ,
  327. 00001010 , 44440000 , 00001010 , 44440000 ,
  328. 00001010 , 44440000 , 00001010 , 44440000 ,
  329. 00001010 , 44440000 , 00001010 , 44440000 ,
  330.  
  331. create p14
  332. 01018080 , 40400000 , 04040808 , 10100000 ,
  333. 01018080 , 40400000 , 04040808 , 10100000 ,
  334. 01018080 , 40400000 , 04040808 , 10100000 ,
  335. 01018080 , 40400000 , 04040808 , 10100000 ,
  336. 01018080 , 40400000 , 04040808 , 10100000 ,
  337. 01018080 , 40400000 , 04040808 , 10100000 ,
  338.  
  339. create p15
  340. 77778888 , 77770000 , dddd2222 , dddd0000 ,
  341. 77778888 , 77770000 , dddd2222 , dddd0000 ,
  342. 77778888 , 77770000 , dddd2222 , dddd0000 , 
  343. 77778888 , 77770000 , dddd2222 , dddd0000 ,
  344. 77778888 , 77770000 , dddd2222 , dddd0000 ,
  345. 77778888 , 77770000 , dddd2222 , dddd0000 ,
  346.  
  347. create p16
  348. 7e7e8181 , c0c03f3f , 00006666 , 99990000 ,
  349. 7e7e8181 , c0c03f3f , 00006666 , 99990000 ,
  350. 7e7e8181 , c0c03f3f , 00006666 , 99990000 ,
  351. 7e7e8181 , c0c03f3f , 00006666 , 99990000 ,
  352. 7e7e8181 , c0c03f3f , 00006666 , 99990000 ,
  353. 7e7e8181 , c0c03f3f , 00006666 , 99990000 ,
  354.  
  355. create p17
  356. e640ffff , ffffe640 , e640ffff , e640e640 ,
  357. e640ffff , ffffe640 , e640ffff , e640e640 ,
  358. e640ffff , ffffe640 , e640ffff , e640e640 ,
  359. e640ffff , ffffe640 , e640ffff , e640e640 ,
  360. e640ffff , ffffe640 , e640ffff , e640e640 ,
  361. e640ffff , ffffe640 , e640ffff , e640e640 , 
  362.  
  363. create p18
  364. 3838c6c6 , 38380000 , 83836c6c , 83830000 ,
  365. 3838c6c6 , 38380000 , 83836c6c , 83830000 ,
  366. 3838c6c6 , 38380000 , 83836c6c , 83830000 ,
  367. 3838c6c6 , 38380000 , 83836c6c , 83830000 ,
  368. 3838c6c6 , 38380000 , 83836c6c , 83830000 ,
  369. 3838c6c6 , 38380000 , 83836c6c , 83830000 ,
  370. decimal
  371. create patterns
  372.  p0 ,  p1 ,  p2 ,  p3 ,  p4 ,  p5 ,  p6 ,
  373.  p7 ,  p8 ,  p9 ,  p10 , p11 , p12 ,
  374.  p13 , p14 , p15 , p16 , p17 , p18 ,
  375.  
  376. : set-pattern  ( n -- )  \ set the current fill pattern
  377.    4 *  patterns +  @  _patptr  !
  378. ;